The 640 MEG Shareware Studio 2/The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO/pascal/tpb4_src.zip/CORE1.PAS

Pascal/Delphi Source File | 1988-09-13 | 21KB | 970 lines

{ TPBoard 4.2 Copyright (c) 1987,88 by Jon Schneider & Rick Petersen
  Portions Copyright (c) 1986,87 by Steve Fox and Les Archambault

  Last modified  ::  9-13-88 7:03 pm
}

{$R-}                             {Range checking off}
{$B-}                             {Boolean complete evaluation off}
{$S-}                             {Stack checking off}
{$I+}                             {I/O checking on}
{$N-}                             {No numeric coprocessor}

Unit Core1;

Interface

Uses
  TPCrt, Dos, Globals, KeyStuff;


procedure AssignAux(var F : Text);

procedure System_Init;

procedure putstat(st, st1 : StrStd);

function Ch_Carck : Boolean;

procedure Ch_Set(R : Word);

procedure Ch_Init;

procedure System_De_Init;

function Ch_Inprdy : Boolean;

procedure Ch_Out(Data : Byte);

procedure Ch_Wait;

procedure Clear_inbuf;

procedure GetTAD(var t : tad_array);

procedure mdhangup;

procedure mdbusy;

function mdring : Boolean;

procedure mdans;

procedure mdinit;

procedure FlushAny(var F);

procedure log(activity : Byte; Text : DosFileName);

procedure SetSect(Dirspec : StrPr);

function input_timeout : Boolean;

function Online : Boolean;

procedure PutByte(b : Byte);

function GetByte(sec : Integer; var timeout : Boolean) : Byte;

function GetChar : Char;

function brk    : Boolean;


  {==========================================================================}


Implementation


  {$F+}
  function AuxOutput(var F : TextRec) : Integer;
    { User written I/O driver to output character }

  var
    i, Row, Col     : Integer;
    Regs            : Dos.Registers;
    ch              : Char;

  begin
    ch := F.BufPtr^[0];
    if user_rec.shift_lock then
      ch := Upcase(ch);
    if printer_copy then
      begin
        Regs.AH := 5;
        Regs.DL := Ord(ch);
        MsDos(Regs);
      end;
    if (Online) then
      begin
        if (ch <> BEL) or local_online then
          begin
            Row := WhereY;
            Col := WhereX;
            if ((ch = LF) or (Col >= 79)) and (Row = 23) then
              begin
                Regs.AH := 6;
                Regs.AL := 1;
                Regs.BH := 15;
                Regs.ch := 0;
                Regs.CL := 0;
                Regs.DH := 22;
                Regs.DL := 79;
                Intr($10, Regs);
                Dec(Row);
                GoToXY(Col, Row);
              end;
            Regs.AH := 6;
            Regs.DL := Ord(ch);
            MsDos(Regs);
          end;
        if remote_copy and (not local_online) then
          begin
            Ch_Out(Ord(ch));
            if ch = CR then
              for i := 1 to user_rec.nulls do
                Ch_Out(Ord(NUL));
            if ch = LF then
              for i := 1 to (user_rec.nulls shr 2) do
                Ch_Out(Ord(NUL))
          end;
      end;
    F.BufPos := 0;
    AuxOutput := 0;
  end;



  function AuxIgnore(var F : TextRec) : Integer;

  begin
    AuxIgnore := 0
  end;



  function AuxOpen(var F : TextRec) : Integer;

  begin
    with F do
      begin
        if mode = fmOutput then
          begin
            InOutFunc := @AuxOutput;
            FlushFunc := @AuxIgnore
          end
        else
          begin
            InOutFunc := @AuxIgnore;
            FlushFunc := @AuxIgnore
          end;
        CloseFunc := @AuxIgnore;
      end;
    AuxOpen := 0;
  end;


  {$F-}
  procedure AssignAux;

  begin                           {AssignAux}
    with TextRec(F) do
      begin
        Handle := $FFFF;
        mode := fmClosed;
        BufSize := 1;
        BufPtr := @Buffer;
        OpenFunc := @AuxOpen;
        name[0] := #0;
      end;
  end;                            {AssignAux}


  procedure System_Init;          {called once when TPBoard first Starts}

  var OrigMode    : Integer;

  begin
    CheckBreak := False;
    OrigMode := LastMode;
    TextMode(OrigMode);
    DetectMultiTasking := True;
    ReinitCrt;
    TextColor(TPCrt.White);
  end;



  procedure putstat(st, st1 : StrStd);
    { Display 'st' on status line }


  var
    Row, Col        : Integer;

  begin
    Col := WhereX;
    Row := WhereY;
    if Row > 23 then
      Row := 23;
    GoToXY(1, 24);
    ClrEol;
    HighVideo;
    Write(st);
    GoToXY(1, 25);
    ClrEol;
    Write(st1);
    LowVideo;
    GoToXY(Col, Row);
  end;


  { Communications Routines}


  procedure Ch_On;                {Turn on the remote channel}

  var
    Regs            : Dos.Registers;

  begin
    with Regs do
      begin
        AH := 6;
        AL := 1;
        DX := Pred(com_port);
        Intr($14, Regs);
      end;
  end;



  procedure Ch_Off;               {Turn off the remote chanel}

  var
    Regs            : Dos.Registers;

  begin
    with Regs do
      begin
        AH := 6;
        AL := 0;
        DX := Pred(com_port);
        Intr($14, Regs);
      end;
  end;


  function Ch_Carck : Boolean;    {check for carrier present}

  var
    Regs            : Dos.Registers;

  begin
    with Regs do
      begin
        AH := 3;
        DX := Pred(com_port);
        Intr($14, Regs);
        Ch_Carck := ((AL and $80) <> 0)
      end;
  end;


  procedure Ch_Set(R : Word);     {set baud rate}

  var
    Regs            : Dos.Registers;

  begin
    rate := R;
    with Regs do
      begin
        case R of
          300 :
            AL := $40;
          1200 :
            AL := $80;
          2400 :
            AL := $A0;
          9600 :
            AL := $E0;
          19200 :
            AL := $00;
        end;
        AL := (AL or 3);
        AH := 0;
        DX := Pred(com_port);
        Intr($14, Regs);
      end;
  end;


  { This procedure MUST be called before doing any I/O. }

  procedure Ch_Init;

  var
    Regs            : Dos.Registers;

  begin
    with Regs do
      begin
        AH := 4;
        DX := Pred(com_port);
        Intr($14, Regs);
        if AX <> $1954 then
          begin
            WriteLn('No Fossil Driver detected, aborting...');
            Halt
          end;
      end;
  end;


  { This procedure shuts-down communications }

  procedure System_De_Init;

  var
    Regs            : Dos.Registers;

  begin
    with Regs do
      begin
        AH := 5;
        DX := Pred(com_port);
        Intr($14, Regs);
      end;
  end;


  { This procedure tells you if there's any input }

  function Ch_Inprdy : Boolean;

  var
    Regs            : Dos.Registers;

  begin
    with Regs do
      begin
        AH := 3;
        DX := Pred(com_port);
        Intr($14, Regs);
        Ch_Inprdy := ((AH and 1) <> 0)
      end;
  end;


  { This procedure reads input from the ring buffer - no wait, assumes ready }

  function Ch_Inp : Byte;

  var
    Regs            : Dos.Registers;

  begin
    with Regs do
      begin
        AH := 2;
        DX := Pred(com_port);
        Intr($14, Regs);
        Ch_Inp := AL
      end;
  end;


  { This procedure writes output, filling the ring buffer if necessary.}

  procedure Ch_Out(Data : Byte);

  var
    Regs            : Dos.Registers;

  begin
    with Regs do
      begin
        AH := 1;
        DX := Pred(com_port);
        AL := Data;
        Intr($14, Regs);
      end;
  end;


  { This procedure waits till the transmit buffer is empty.}

  procedure Ch_Wait;

  var
    Regs            : Dos.Registers;

  begin
    with Regs do
      begin
        repeat
          AH := 3;
          DX := Pred(com_port);
          Intr($14, Regs);
        until (AH and $40) <> 0
      end;
  end;


  procedure Clear_inbuf;

  var
    Regs            : Dos.Registers;

  begin
    with Regs do
      begin
        AH := 10;
        DX := Pred(com_port);
        Intr($14, Regs);
      end;
  end;


  { Clock routines}

  procedure GetTAD(var t : tad_array);
   { Return a 6 element integer array of the current system time in
     seconds, minutes, hours, day, month, and year. }

  var
    temp1, temp2, temp3, temp4 : Word;

  begin

    GetTime(temp1, temp2, temp3, temp4);
    t[0] := temp3;                { secs }
    t[1] := temp2;                { mins }
    t[2] := temp1;                { hrs  }

    GetDate(temp1, temp2, temp3, temp4);
    t[3] := temp3;                { day }
    t[4] := temp2;                { mon }
    t[5] := temp1-1900;           { yr  }

  end;



  { Modem routines}

  function mdresult(secs : Integer) : Str3;
    {get result code from mdodem with timeout}

  var
    count           : Real;
    ch              : Char;
    result          : Str3;

  begin
    result := '';
    count := secs/0.001;
    repeat
      repeat
        count := count-1.0;
        Delay(1);
      until (Ch_Inprdy) or (count <= 0);
      if count > 0 then
        begin
          ch := Chr(Ch_Inp);
          if ch in ['0'..'9'] then
            result := result+ch;
          if Length(result) > 2 then
            Delete(result, 1, 1);
        end;
    until ((ch = CR) and (Length(result) > 0)) or (count <= 0);
    if count > 0 then
      mdresult := result
    else
      mdresult := '';
  end;



  procedure mdsend(st : StrStd);
    { Send a command string to the modem  }

  var
    i, n            : Byte;

  begin
    while Ch_Inprdy do
      i := Ch_Inp;                {clear buffer}
    for i := 1 to Length(st) do
      begin
        if st[i] = '~' then
          Delay(1000)
        else if st[i] = '|' then
          Ch_Out(Ord(CR))
        else
          Ch_Out(Ord(st[i]));
        Delay(100);
        if (Ch_Inprdy) then
          n := Ch_Inp;            {eat echo, if any}
      end;
  end;



  procedure mdhangup;
    { Hangup modem }

  var
    i               : Integer;
    bt              : Byte;

  begin
    repeat
      Ch_Off;
      Delay(2000);
      Ch_On;
      if Ch_Carck then
        begin
          for i := 1 to 3 do
            Ch_Out(Ord(Attention));
          Delay(2000);
          mdsend(hang_up_str);
        end;
    until not Ch_Carck;
    while Ch_Inprdy do
      bt := Ch_Inp;               {clear buffer}
    Ch_Set(modem_rate)
  end;



  procedure mdbusy;
    { Take modem off hook to present a busy signal to incoming callers }

  begin
    mdsend(off_hook_str);         { Take modem off hook }
  end;



  function mdring : Boolean;
    { Determine if the phone is ringing }

  var
    ans             : Char;

  begin
    ans := ' ';                   {initialize}
    if Ch_Inprdy then
      ans := Chr(Ch_Inp);
    if ans = RING then
      begin
        ans := Chr(Ch_Inp);       {get CR from modem}
        mdring := True;
      end
    else
      mdring := False;
  end;



  procedure mdans;
    { Detect and set system to rate at which modem answered phone }

  var
    result          : Str3;

  begin
    mnp := False;
    Delay(answer_delay);
    if (not modem_answer) then
      begin
        mdsend(answer_str);       { Let the modem answer }
        Delay(answer_delay);
        result := mdresult(15);   { first check for OK response }
        if (result = OKAY) or (result = '') then
          result := mdresult(40); { get actual speed code response}
      end
    else
      result := mdresult(40);
    if result = connect300 then
      Ch_Set(300)
    else if result = connect1200 then
      Ch_Set(1200)
    else if result = connect2400 then
      Ch_Set(2400)
    else if result = connect9600 then
      Ch_Set(9600)
    else if result = connect1200ecc then
      begin
        Ch_Set(1200);
        mnp := True;
      end
    else if result = connect2400ecc then
      begin
        Ch_Set(2400);
        mnp := True;
      end
    else if result = connect9600ecc then
      begin
        Ch_Set(9600);
        mnp := True;
      end
    else
      mdhangup;
    Delay(500);                   { Make sure carrier is stable }
    Clear_inbuf;
  end;



  procedure mdinit;
    { Ensure the modem is hung up, initialized, and ready to wait for a ring. }

  var
    bt              : Byte;

  begin
    bt := 0;
    System_De_Init;               {clear communications chanel}
    Delay(500);
    Ch_Init;                      { re-initialize it}
    Ch_Set(modem_rate);           { set baud }
    Ch_Out(Ord(CR));              { get modem's attention}
    repeat
      Delay(1000);
      Inc(bt);
      Clear_inbuf;                {clear buffer}
      mdsend(init_str);
    until (mdresult(5) = OKAY) or (bt > 4);
    if bt > 4 then
      begin
        putstat('Modem Initialization Problem...', ' ');
        Delay(7500);
      end;
  end;


  procedure FlushAny(var F);

  var
    Handle          : Integer absolute F; {File handle is the first word of a file's FIB}
    Regs            : Dos.Registers;

  begin
    Regs.AH := $45;               {DOS function to duplicate a file handle}
    Regs.BX := Handle;
    MsDos(Regs);
    if Odd(Regs.flags) then       {Check if carry flag is set}
      begin
        WriteLn('Unable to duplicate file handle');
        Halt
      end;
    Regs.BX := Regs.AX;           {Put new file handle into BX}
    Regs.AH := $3E;               {Dos function to close a file handle}
    MsDos(Regs);
    if Odd(Regs.flags) then       {Check if carry flag is set}
      begin
        WriteLn('Unable to close duplicated handle');
        Halt
      end
  end {FlushAny} ;



  procedure log(activity : Byte; Text : DosFileName);

  var
    t               : tad_array;

  begin
    Seek(logr_file, FileSize(logr_file));
    GetTAD(t);
    if ((login_t[2] > 21) and (t[2] < 2) and (login_t[3] = t[3])) then
      Mem[$40:$70] := 1;
    GetTAD(logr_rec.date);
    logr_rec.action := activity;
    if valid_pw then
      logr_rec.user := user_loc
    else
      logr_rec.user := 0;
    logr_rec.Text := Text;
    Write(logr_file, logr_rec);
    FlushAny(logr_file);
  end;



  procedure SetSect(Dirspec : StrPr);
    { Set to file section }

  var
    OK              : Boolean;
    i               : Integer;

  begin
    {$I-}
    ChDir(Dirspec); {$I+}
    OK := (IoResult = 0);
    if (not OK) then
      begin
        {$I-}
        MkDir(Dirspec);
        ChDir(Dirspec); {$I+}
        i := IoResult
      end;
  end;



  function input_timeout : Boolean;
    {decrement counter to determine timeout}

  var
    Regs            : Dos.Registers;
    test            : Word;

  begin
    Regs.AH := 0;
    Intr($1A, Regs);
    if Regs.AL <> 0 then
      Mem[$40:$70] := 1;
    test := Regs.DX;
    if test <> time_count then
      begin
        time_count := test;
        if (not local_online) then
          input_time := input_time-1.0;
        if local_online then
          input_time := input_time-0.2;
      end;
    if input_time < 0.0 then
      begin
        WriteLn(com, ' +++ Input timed out +++');
        SetSect(HomName);
        log(13, ' ');
        remote_online := False;
        if local_online then
          local_online := False;  {sysop timeout}
        mdhangup;
        input_timeout := True;
      end
    else
      input_timeout := False;
  end;



  function Online : Boolean;
    { Determine whether system is still online - local or remote }

  begin
    if remote_online then
      if Ch_Carck then
        Online := True
      else
        begin
          putstat('Carrier lost', ' ');
          SetSect(HomName);
          log(12, ' ');
          mdhangup;
          remote_online := False;
          Online := False;
        end
    else
      Online := local_online
  end;



  procedure PutByte(b : Byte);

  begin
    if Ch_Carck then
      Ch_Out(b)
  end;



  function GetByte(sec : Integer; var timeout : Boolean) : Byte;
    { Get byte from modem with 'sec' seconds timeout }

  var
    test            : Word;
    count           : Real;
    Regs            : Dos.Registers;

  begin
    time_count := 0;
    count := sec*18.2;
    while (not Ch_Inprdy) and (Ch_Carck) and (count > 0.0) do
      begin
        Regs.AH := 0;
        Intr($1A, Regs);
        if Regs.AL <> 0 then
          Mem[$40:$70] := 1;
        test := Regs.DX;
        if test <> time_count then
          begin
            time_count := test;
            count := count-1.0;
          end;
      end;
    timeout := (not Ch_Carck) or (count <= 0.0);
    if timeout then
      GetByte := Ord(NUL)
    else
      GetByte := Ch_Inp;
  end;



  function GetChar : Char;
    { Get character: no wait, no echo }

  var
    ch, command     : Char;
    key_char        : string[1];

  begin
    if Queue <> '' then
      begin
        key_char := Queue[1];
        Delete(Queue, 1, 1);
        key_char := StuffKey(key_char);
      end;
    if KeyPressed then
      begin
        ch := ReadKey;
        if ch = NUL then
          begin
            ch := ReadKey;
            case ch of
              #35 :               { Alt H }
                ch := LF;
              #59 :               { F1 }
                ch := ^W;
              #60 :               { F2 }
                ch := ^E;
              #61 :               { F3 }
                ch := ^R;
              #62 :               { F4 }
                begin
                  if in_chat and remote_online then
                    begin
                      case mode of
                        message_mode :
                          command := 'M';
                        files_mode :
                          command := 'F';
                      else
                        command := 'U';
                      end;
                      Queue := ^E+^C+'X V Y '+command+CR+^E+^W+CR+
                      'You are now validated.'+CR;
                    end;
                  ch := NUL;
                end;
              #68 :               { F10 }
                ch := ^t;
            else
              ch := NUL;
            end
          end;
        chl := ch;
        if (not Online) and (not(ch in [^C, LF, CR, FF])) then
          ch := NUL;
        case ch of
          ^W :
            begin
              op_chat := True;
              ch := CR
            end;
          ^E :
            begin
              remote_copy := not remote_copy;
              if remote_copy then
                begin
                  putstat('Remote copy on', ' ');
                  new_dir := True
                end
              else
                putstat('Remote copy off', ' ');
              ch := NUL
            end;
          ^R :
            begin
              delay_down := not delay_down;
              if delay_down then
                putstat('Delayed shutdown on', ' ')
              else
                putstat('Delayed shutdown off', ' ');
              ch := NUL
            end;
          ^t :
            begin
              remote_online := False;
              mdhangup;
              ch := NUL
            end;
          LF :
            begin
              if Online then
                putstat(
                  '^W or F1: CHAT             ^E or F2:  Toggle Remote Copy       ^T or F10: Twit',
                  '^R or F3: Delayed Shutdown       F4:  Validate User from CHAT')
              else
                putstat('^C: Shutdown TPBoard, ^L: Local use', ' ');
              if Online then
                ch := NUL;
            end
        end
      end
    else if remote_online and remote_copy and Ch_Carck and Ch_Inprdy then
      ch := Chr($7F and Ch_Inp)
    else
      ch := NUL;
    GetChar := ch
  end;



  function brk    : Boolean;
    { Check for break or pause }

  var
    test            : Boolean;
    ch              : Char;

  begin
    if (not abort) then
      begin
        input_time := timeout*18.2;
        time_count := 0;
        ch := GetChar;
        if ch = DC3 then          { ^S }
          repeat
            ch := GetChar
          until (not Online) or (ch <> NUL) or (input_timeout);
        test := (not Online) or (ch = ETX) or (ch = #$0B) or (Upcase(ch) = 'K')
        or (ch = ESC);
        if test then
          begin
            mult_cmds := False;
            Cmd_Queue := '';
          end;
        brk := test;
      end
    else
      begin
        abort := False;
        brk := True;
      end;
  end;


end.                              { of CORE1.PAS }